home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / clean / sun3.lha / Sun3 / _system.abc < prev    next >
Text File  |  1992-08-07  |  7KB  |  421 lines
  1. | The system environment (for version numbers 0.80 etc)
  2. |
  3. .comp 800 111111111
  4. .start _nostart_
  5. .endinfo
  6.  
  7. .export    EMPTY INT BOOL CHAR STRING REAL FILE _STRING_
  8. .export    _reserve _cycle_in_spine _hnf 
  9. .export _type_error _match_error _print_graph _eval_to_nf
  10. .export    _Tuple
  11. .export    _Select _select_code
  12. .export    _Nil _Cons
  13.  
  14. .export    e_system_AP
  15. .export    e_system_IF e_system_lIF e_system_sIF e_system_nIF
  16.  
  17. .export    _Defer _defer_code
  18.  
  19. .export    _S.1 _S.2 _S.3 _S.4 _S.5 _S.6 n_S.1 n_S.2 n_S.3 n_S.4 n_S.5 n_S.6
  20.  
  21. || don't change the order of the following 7 descriptors
  22.  
  23. .desc _STRING_    _hnf    _hnf    0    ""
  24. .desc STRING    _hnf    _hnf    0    "STRING"
  25. .desc FILE    _hnf    _hnf    0    "FILE"
  26. .desc REAL    _hnf    _hnf    0    "REAL"
  27. .desc INT    _hnf    _hnf    0    "INT"
  28. .desc BOOL    _hnf    _hnf    0    "BOOL"
  29. .desc CHAR    _hnf    _hnf    0    "CHAR"
  30.  
  31. .desc EMPTY    _hnf    _hnf    0    "EMPTY"
  32.  
  33. .desc _Tuple    _hnf    _hnf    32    "_Tuple"
  34. .desc _Select    _hnf    _hnf    2    "_Select"
  35. .desc _Nil    _hnf    _hnf    0    "Nil"
  36. .desc _Cons    _hnf    _l_cons    2    "Cons"
  37.  
  38. .desc e_system_AP    _hnf    e_system_lAP    2    "AP"
  39. .desc e_system_IF    e_system_nIF    e_system_lIF    3    "IF"
  40.  
  41. .desc _Defer    _hnf    _apply_error    1    "_Defer"
  42.  
  43. .n 1 _Defer
  44. .o 0 0
  45. _defer_code:
  46.     print    "Error: defer code entered\n"
  47.     halt
  48.  
  49. .o 0 2 i i
  50. _match_error:
  51.     print    "Run time error, rule \'"
  52.     printD
  53.     print    "\' in module \'"
  54.     printD
  55.     print    "\' does not match\n"
  56.     halt
  57.  
  58. .o 2 0
  59. _l_cons:
  60.     create
  61.     push_a        2
  62.     push_args    2 2 2
  63.     fill        _Cons 2 _hnf 2
  64.     update_a    0 2
  65.     pop_a        2
  66. .d 1 0
  67.     rtn
  68.  
  69. .desc _S.1 n_S.1 _hnf 1 "_S.1"
  70. .n 1 _S.1
  71. .o 1 0
  72. n_S.1:
  73.     push_node _reserve 1
  74.     jsr_eval
  75.     get_node_arity 0
  76.     pushI 1
  77.     push_arg_b 0
  78.     jsr_eval
  79.     getWL 2
  80.     fill_a 0 2
  81.     release
  82.     pop_a 2
  83. .d 1 0
  84.     rtn
  85.  
  86. .desc _S.2 n_S.2 _hnf 1 "_S.2"
  87. .n 1 _S.2
  88. .o 1 0
  89. n_S.2:
  90.     push_node _reserve 1
  91.     jsr_eval
  92.     get_node_arity 0
  93.     pushI 2
  94.     push_arg_b 0
  95.     jsr_eval
  96.     getWL 2
  97.     fill_a 0 2
  98.     release
  99.     pop_a 2
  100. .d 1 0
  101.     rtn
  102.  
  103. .desc _S.3 n_S.3 _hnf 1 "_S.3"
  104. .n 1 _S.3
  105. .o 1 0
  106. n_S.3:
  107.     push_node _reserve 1
  108.     jsr_eval
  109.     get_node_arity 0
  110.     pushI 3
  111.     push_arg_b 0
  112.     jsr_eval
  113.     getWL 2
  114.     fill_a 0 2
  115.     release
  116.     pop_a 2
  117. .d 1 0
  118.     rtn
  119.  
  120. .desc _S.4 n_S.4 _hnf 1 "_S.4"
  121. .n 1 _S.4
  122. .o 1 0
  123. n_S.4:
  124.     push_node _reserve 1
  125.     jsr_eval
  126.     get_node_arity 0
  127.     pushI 4
  128.     push_arg_b 0
  129.     jsr_eval
  130.     getWL 2
  131.     fill_a 0 2
  132.     release
  133.     pop_a 2
  134. .d 1 0
  135.     rtn
  136.  
  137. .desc _S.5 n_S.5 _hnf 1 "_S.5"
  138. .n 1 _S.5
  139. .o 1 0
  140. n_S.5:
  141.     push_node _reserve 1
  142.     jsr_eval
  143.     get_node_arity 0
  144.     pushI 5
  145.     push_arg_b 0
  146.     jsr_eval
  147.     getWL 2
  148.     fill_a 0 2
  149.     release
  150.     pop_a 2
  151. .d 1 0
  152.     rtn
  153.  
  154. .desc _S.6 n_S.6 _hnf 1 "_S.6"
  155. .n 1 _S.6
  156. .o 1 0
  157. n_S.6:
  158.     push_node _reserve 1
  159.     jsr_eval
  160.     get_node_arity 0
  161.     pushI 6
  162.     push_arg_b 0
  163.     jsr_eval
  164.     getWL 2
  165.     fill_a 0 2
  166.     release
  167.     pop_a 2
  168. .d 1 0
  169.     rtn
  170.  
  171. .n 2 _Select
  172. .o 1 0
  173. _select_code:
  174.     print    "Error: select code entered"
  175.     halt
  176.  
  177. .o 0 0
  178. e_system_lAP:
  179.     print    "Error: lazy entry of AP entered"
  180.     halt
  181.  
  182. .o 2 0
  183. e_system_lIF:
  184.     repl_args 2 2
  185. .d 3 0
  186.     jmp eval_args_if
  187.  
  188. .n 3 e_system_IF
  189. .o 1 0
  190. e_system_nIF:
  191.     push_node _reserve 3
  192. .d 3 0
  193.     jsr eval_args_if
  194. .o 1 0
  195.     getWL 1
  196.     fill_a 0 1
  197.     release
  198.     pop_a 1
  199. .d 1 0
  200.     rtn
  201.  
  202. .o 3 0
  203. eval_args_if:
  204.     jsr_eval
  205.     pushB_a 0
  206.     pop_a 1
  207. .o 2 1 b
  208. e_system_sIF:
  209.     jmp_false IFelse
  210.     update_a 0 1
  211.     pop_a 1
  212.     jmp_eval
  213. IFelse:
  214.     pop_a 1
  215.     jmp_eval
  216.  
  217. .n 0 _Nil
  218. .o 1 0
  219. _hnf:
  220. .d 1 0
  221.     rtn
  222.  
  223. .n 0 EMPTY
  224. .o 1 0
  225. _cycle_in_spine:
  226. .o 1 0
  227. _reserve:
  228.     print    "Run Time Error: cycle in spine detected\n"
  229.     halt
  230.  
  231. .o 0 0
  232. _type_error:
  233.     print    "Run Time Error: type error\n"
  234.     halt
  235.  
  236. .o 0 0
  237. _apply_error:
  238.     print    "Run Time Error: apply error\n"
  239.     halt
  240.  
  241. .o 1 0
  242. _print_graph:
  243. .d 1 0
  244.     jsr        _print
  245. .o 0 0
  246.     print_sc    "\n"
  247.     halt
  248.  
  249. .o 1 0
  250. _print:    
  251.     pushI        0            | push the bracket count
  252. _continue_print:
  253.     jsr_eval
  254.     eq_desc        _Cons 2 0
  255.     jmp_true    _print_list
  256.     eq_desc        _Nil 0 0
  257.     jmp_true    _print_nil
  258.     eq_nulldesc    _Tuple 0
  259.     jmp_true    _print_tuple
  260.     get_node_arity    0
  261.     eqI_b        0 0            | check if arity is zero
  262.     jmp_true    _print_last
  263.     print_sc    "("
  264.     print_symbol_sc    0
  265.     push_b        0
  266.     push_b        0            | replace the node by
  267.     repl_args_b                | leave arity on b-stack
  268. _print_args:
  269.     print_sc    " "
  270.     eqI_b        1 0            | check if last argument
  271.     jmp_true    _print_last_arg
  272. .d 1 0
  273.     jsr        _print
  274. .o 0 0
  275.     decI                    | decrease argument count
  276.     jmp        _print_args
  277. _print_last_arg:
  278.     pop_b        1            | remove argument count
  279.     incI                    | increment bracket count
  280.     jmp        _continue_print        | optimised tail recursion!
  281. _print_last:
  282.     print_symbol_sc    0
  283.     pop_b        1            | remove arity
  284.     pop_a        1            | remove node
  285. _print_brackets:
  286.     eqI_b        0 0            | stop printing brackets if
  287.     jmp_true    _exit_brackets        | bracket count is zero
  288.     print_sc    ")"
  289.     decI                    | decrement bracket count
  290.     jmp        _print_brackets
  291. _exit_brackets:
  292.     pop_b        1            | remove bracket count
  293. .d 0 0
  294.     rtn
  295.  
  296. _print_list:
  297.     print_sc    "["
  298. _print_rest_list:
  299.     repl_args    2 2
  300. .d 1 0
  301.     jsr        _print
  302. .o 0 0
  303.     jsr_eval
  304.     eq_desc        _Nil 0 0
  305.     jmp_true    _print_last_list
  306.     print_sc    ","
  307.     jmp        _print_rest_list            
  308. _print_last_list:
  309.     print_sc    "]"
  310.     pop_a        1
  311.     jmp        _print_brackets
  312.                     
  313. _print_nil:
  314.     print_sc    "[]"
  315.     pop_a        1
  316.     jmp        _print_brackets
  317.  
  318. _print_tuple:            
  319.     print_sc    "("
  320.     get_node_arity    0
  321.     push_b        0
  322.     push_b        0
  323.     repl_args_b
  324. _print_rest_tuple:
  325. .d 1 0
  326.     jsr        _print
  327. .o 0 0
  328.     decI
  329.     eqI_b        0 0
  330.     jmp_true    _exit_print_tuple
  331.     print_sc    ","
  332.     jmp        _print_rest_tuple
  333. _exit_print_tuple:
  334.     pop_b        1
  335.     print_sc    ")"
  336.     jmp        _print_brackets
  337.                         
  338. .o 1 0
  339. _eval_to_nf:
  340. .d 1 0
  341.     jsr        _eval
  342. .o 0 0
  343.     halt
  344.  
  345. .o 1 0
  346. _eval:    
  347.     pushI        0            | push the bracket count
  348. _continue_eval:
  349.     jsr_eval
  350.     eq_desc        _Cons 2 0
  351.     jmp_true    _eval_list
  352.     eq_desc        _Nil 0 0
  353.     jmp_true    _eval_nil
  354.     eq_nulldesc    _Tuple 0
  355.     jmp_true    _eval_tuple
  356.     get_node_arity    0
  357.     eqI_b        0 0            | check if arity is zero
  358.     jmp_true    _eval_last
  359.     push_b        0
  360.     push_b        0            | replace the node by
  361.     repl_args_b                | leave arity on b-stack
  362. _eval_args:
  363.     eqI_b        1 0            | check if last argument
  364.     jmp_true    _eval_last_arg
  365. .d 1 0
  366.     jsr        _eval
  367. .o 0 0
  368.     decI                    | decrease argument count
  369.     jmp        _eval_args
  370. _eval_last_arg:
  371.     pop_b        1            | remove argument count
  372.     incI                    | increment bracket count
  373.     jmp        _continue_eval        | optimised tail recursion!
  374. _eval_last:
  375.     pop_b        1            | remove arity
  376.     pop_a        1            | remove node
  377. _eval_brackets:
  378.     eqI_b        0 0            | stop printing brackets if
  379.     jmp_true    _exit_eval_brackets    | bracket count is zero
  380.     decI                    | decrement bracket count
  381.     jmp        _eval_brackets
  382. _exit_eval_brackets:
  383.     pop_b        1            | remove bracket count
  384. .d 0 0
  385.     rtn
  386.  
  387. _eval_list:
  388. _eval_rest_list:
  389.     repl_args    2 2
  390. .d 1 0
  391.     jsr        _eval
  392. .o 0 0
  393.     jsr_eval
  394.     eq_desc        _Nil 0 0
  395.     jmp_true    _eval_last_list
  396.     jmp        _eval_rest_list            
  397. _eval_last_list:
  398.     pop_a        1
  399.     jmp        _eval_brackets
  400.                     
  401. _eval_nil:
  402.     pop_a        1
  403.     jmp        _eval_brackets
  404.  
  405. _eval_tuple:            
  406.     get_node_arity    0
  407.     push_b        0
  408.     push_b        0
  409.     repl_args_b
  410. _eval_rest_tuple:
  411. .d 1 0
  412.     jsr        _eval
  413. .o 0 0
  414.     decI
  415.     eqI_b        0 0
  416.     jmp_true    _exit_eval_tuple
  417.     jmp        _eval_rest_tuple
  418. _exit_eval_tuple:
  419.     pop_b        1
  420.     jmp        _eval_brackets
  421.